perm filename GRED.F4[1,MUS] blob
sn#075921 filedate 1973-12-04 generic text, type T, neo UTF8
00100 C**** SUBRS. VLINE, ASKIT, GRED, DELETE, DPYNEW ********
00200 C SUBRS. VLINE, ASKIT, GRED, LPEN, DELETE, DPYNEW, PLTCMD
00300
09700
09800 SUBROUTINE VLINE(RJC,RJD,RJE,RJF)
09900 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
10000 6 TYPE 3
10100 ACCEPT F78F,RJC,RJD,RJE,RJF
10110 REREAD FA1,ASK
10200 IF(RJC.EQ.99)RETURN
10300 IF(ASK.NE.'L')GO TO 66
10350 C TYPE 'L' FOR LIGHT-PEN
10400 DO 67 K=1,2
10500 RJD=RY
10600 CALL LPEN(RJC,RY,RX)
10700 67 IF(RJC.EQ.99)RETURN
10800 RJE=RY
10900 C LIGHT PEN IS READ TWICE
11000 66 ASK=-1
11100 IF(RJF.LT.100)GO TO 1
11200 RJF=RJF-100
11300 C FOR 'ASK' ADD 100 TO PARAM NUMBER GIVEN.
11400 ASK=0
11500 1 CALL BOX(-1,RJD,1)
11600 CALL BOX(-2,RJE,1)
11700 C PUTS UP TWO VERTICAL LINES
11800 3 FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #'/)
11900 END
12000
12100 SUBROUTINE ASKIT
12200 COMMON /DPY/ST(4000),WDS(250),MEDIT,IGO
12500 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
12600 COMMON /XRN/RN(4000)
12650 IGO=0
12700 CALL DPYNEW
12800 X=ST(2)
12900 CALL BOX(JY,RN(JY+3),STFF)
13000 ST(2)=X
13100 TYPE 1
13200 ACCEPT FA1,K
13300 IF(K.EQ.'G')ASK=-1
13400 CALL DPYNEW
13450 IGO=1
13500 1 FORMAT(' N=NO, <CR>=YES, G=GO '$)
13700 END
13800
13900 SUBROUTINE GRED
14100 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
14200 COMMON/ALF/INP(72),ML
14300 COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
14400 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)/XRN/RN(4000)
14500 COMMON /PTR/PWDS(250),ITEM,L,I,IX/POSI/STFF(8),JJB,POS
14600 DIMENSION R(8,100)
14900
14950 EQUIVALENCE (R,RN(3001))
15000 RC=999
15100 IZ=0
15200 C COUNTER
15300 IF(INP(1).NE.'A'.AND.INP(1).NE.'D')GO TO 1
15400 C LEAVES ROUTINE
15500 7 CALL VLINE(RJQ(1),Z,POS,RX)
15600 C PUTS UP TWO VERTICAL LINES
15620 IF(RJQ(1).LT.99)GO TO 70
15630 JA=98
15640 RETURN
15700 70 IF(POS.EQ.0)POS=200
15800 C 0,0 DOES WHOLE STAFF
15900 IF(INP(1).NE.'A')GO TO 4
16000 TYPE 55
16100 ACCEPT F78F,V
16150 REREAD FA1,K
16175 C TYPE 'L' FOR LIGHT PEN
16200 IF(V(1).EQ.99)GO TO 7
16300 IF(K.NE.'L')GO TO 66
16400 DO 67 K=1,2
16500 V(2)=RY
16600 CALL LPEN(V(1),RY,RX)
16700 67 IF(V(1).EQ.99)GO TO 7
16800 V(3)=RY
16900 66 JA=0
17000 GO TO 14
17100 4 JA=98
17200 C FOR DELETIONS
17300 V(1)=0
17400 14 NX=0
17500 C LOOP STARTS HERE
17600 140 NX=NX+1
17700 142 JY=PWDS(NX)
17800 RB=RN(JY+2)
17900 IF(RTLINE(JY).OR.RB.LT.Z.OR.RB.GT.POS)GO TO 6
18000 RB=RN(JY+1)
18100 IF(V(1).NE.12.AND.RC.EQ.999)GO TO 143
18200 C USE P12 TO INVERT STEM, BEAM AND SLURS ALL AT ONCE.
18300 RC=0
18400 IF(RB.EQ.8.OR.RB.EQ.9)GO TO 141
18500 143 IF(RB.NE.RX.AND.RX.NE.0)GO TO 6
18600 IF(ASK)GO TO 100
18700 CALL ASKIT
18800 IF(K.EQ.'N')GO TO 6
18900 IF(K.EQ.'X')GO TO 19
19000 100 IF(INP(1).EQ.'A')GO TO 141
19100 RJB=NX
19200 CALL DELETE
19300 IF(NX.GT.ITEM)GO TO 1
19400 GO TO 142
19450 141 IF(IZ.GE.97)GO TO 9
19475 C THERE'S A LIMIT TO THE R ARRAY 4/18/73
19500 IZ=IZ+1
19600 C FOUND AN ITEM
19700 R(1,IZ)=22
19800 R(2,IZ)=NX
19900 10 IZ=IZ+1
20000 IF(RC.EQ.999)GO TO 11
20100 IF(RB.EQ.1)GO TO 30
20200 31 RC=RN(JY+7)
20300 IF(RB.EQ.9)GO TO 32
20400 C NEXT INVERTS DIP
20500 RB=-4
20510 IF(RN(JY+8).LT.-1)RB=-1.4
20520 C 2 AND .7 ARE HGTS SET IN 'BEAMS'
20600 IF(RC)RB=-RB
20700 R(3,IZ)=4
20800 R(4,IZ)=RN(JY+4)+RB
20900 R(6,IZ)=RN(JY+5)+RB
21000 R(5,IZ)=5
21100 33 R(1,IZ)=7
21200 R(2,IZ)=-RC
21300 GO TO 6
21400 32 IF(RC.LT.20)GO TO 34
21500 C THIS IS FOR BEAMS
21600 RC=10-RC
21700 GO TO 33
21800 34 RC=-10-RC
21900 GO TO 33
22000
22200 C NEXT INVERTS STEMS EITHER WAY. USE ANY #>11 WITH CODE 1 TO INVERT.
22300 C MUST! BE FIRST IN LIST!!!
22400 C RC=0
22500 30 RB=RN(JY+5)
22600 IF(RB.LT.10)GO TO 12
22700 C NO STEM < 10
22800 RC=10
22900 IF(RB.GE.20)RC=-RC
23000 RB=RB+RC
23100 12 V(1)=5.
23200 V(2)=RB
23300 C SO IT WILL DISPLAY RESULT
23400 11 DO 8 K=1,8
23500 8 R(K,IZ)=V(K)
23600 6 IF(NX.LT.ITEM)GO TO 140
23700 19 IF(INP(1).NE.'A')GO TO 1
23800 9 R(1,IZ+1)=222
23900 R(1,IZ+2)=100.
24000 REND=-1.
24100 1 CALL HYDPOG(3)
24300 53 FORMAT(' TYPE STAFF #, POS1, POS2 AND CODE #'/)
24400 55 FORMAT(' TYPE',3(' P#, CHNG ')/)
24500 END
24600
24700 SUBROUTINE LPEN(A,B,C)
24710 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
24800 COMMON /POSI/STFF(8),JJB,POS
25100 5 CALL SETCUR(0,100,0)
25200 TYPE 17
25300 ACCEPT F78F,A
25400 IF(A.EQ.99)RETURN
25500 C TYPE 99 TO BACK UP
25600 CALL RDCUR(M,L)
25700 B=(M+512.0)/5.12
25800 C B=HORIZ. STEP NUM.
25900 CALL CLRCUR
26000 DO 13 K=1,8
26100 M=STFF(K)+60.
26200 IF(L.GT.M)GO TO 13
26300 A=K-4
26400 C A=STAFF NUM.
26500 GO TO 8
26600 13 CONTINUE
26700 17 FORMAT(' TYPE <CR> TO SET POINT'/)
26900 8 C=IFIX((L-STFF(K)+21.)/7.+.5)
27000 C FINDS VERT. NOTE NUM.
27100 TYPE F78F,A,B
27300 END
28000
28100
28200
30000 SUBROUTINE DELETE
30100 IMPLICIT INTEGER(A-Q,S-Z)
30200 REAL PWDS
30300 COMMON/DL/X22,SAVER,NAME
30600 COMMON /XRN/RN(4000)
30800 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
30900 COMMON/PTR/PWDS(250),ITEM,L,I,IX
31000 COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
31100 EQUIVALENCE (RJD,RJQ(2)),(RJC,RJQ(1)),(ST2,ST(2))
31200
31300 C 99 N DELETES ALL ITEMS STARTING WITH ITEM N.
31400 C 99 0 0 N DELETES ALL LINES BUT LINE N.
31500 IF(JA.NE.98)GO TO 7542
31600 IF(RJB.LE.0)RETURN
31700 C ERROR TRAP
31800 ITEM=ITEM+1
31900 X22=RJB
32000 MEDIT=PWDS(X22)
32100 7542 IF(X22.NE.0)GO TO 1
32200 JA=0
32300 IF(RJB.NE.0)GO TO 273
32400 C 99 0 0 -1 WILL DELETE ALL LINES EXCEPT! -1.
32500 IF(RJD.EQ.10.)RJD=0
32600 671 DEL=-1
32700 X22=ITEM+1
32900 371 X22=X22-1
33000 C BACKS THROUGH ARRAY
33200 IF(X22.EQ.0)GO TO 71
33400 700 X=PWDS(X22)+3
33500 C 99 0 0 -1 DELETES ALL EXCEPT LINE -1.
33600 IF(RN(X).EQ.RJD)GO TO 371
33700 672 MEDIT=PWDS(X22)
33800 GO TO 571
33900
34100 71 JB=ITEM+1
34400 DEL=0
34500 GO TO 195
34600 273 ITEM=RJB-1
34700 C RESETS ITEM #
34800 SAVER=-1
34900 C TO HELP RECOVER FROM ERROR
35000 CALL SAVIT
35100
35200 571 X=ITEM+1
35300 GO TO 171
35400 1 X=ITEM
35500 171 IX=I
35600 L=RN(MEDIT)+3.0
35700 C SIZE OF DELETION
35800 I=IX-L
35900 CALL LOOP(MEDIT,I,1,0,L,RN)
36000 JY=WDS(X22+1)-WDS(X22)
36100 CALL LOOP(WDS(X22)+2,WDS(X),1,0,JY,ST)
36200 RJF=L
36300 K=X22
36400 194 L=K+1
36500 WDS(L)=WDS(L+1)-JY
36600 PWDS(K)=PWDS(L)-RJF
36700 K=L
36800 IF(K.LT.X)GO TO 194
36900 C ABOVE RESHUFFLES POINTER ARRAYS. X=ITEM+1
37000 ITEM=ITEM-1
37100 IF(X22.GT.ITEM)X22=ITEM
37200 IF(DEL)GO TO 700
37300 JB=ITEM
37400 ITEM=ITEM-1
37500 195 ST2=WDS(JB)
37600 271 CALL DPYNEW
37900 END
38000
38100
38200 SUBROUTINE DPYNEW
38210 COMMON/DPY/ST(4000),WDS(250),MEDIT,IGO
38300 CALL ACCPOG(1)
38400 IF(IGO.GT.0)RETURN
38450 CALL DPYOUT(1)
38600 END
38700
38800 SUBROUTINE PLTCMD
38900 CC IMPLICIT INTEGER(A-Q,S-Z)
39000 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100 DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200 COMMON /DL/X22,SAVER,NAME /ALF/INP(72),ML
39400 COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700 EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800 1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(NMS(1),INP(41))
39900 1,(RMOV1(1),INP(51)),(RMOV2(1),INP(61))
40000
40100 IF(I2.NE.'X')GO TO 1
40150 CC ML=' '
40200 I2=0
40300 RXC=0
40400 RMOV1(1)='Y'
40500 NAME=0
40600 14 KA=0
40700 3 KA=KA+1
40710 CC IF(ML.EQ.' ')GO TO 15
40715 IF(ML.EQ.0)GO TO 15
40720 K=K-2
40725 ML=ML-1
40730 IF(ML.EQ.0)GO TO 10
40740 GO TO 31
40800 15 TYPE 2,KA
40900 ACCEPT 11,K,ML
40950 C TYPE LAST NAME, NUMBER FOR A SERIES
41000 50 IF(K.EQ.' ')GO TO 10
41100 IF(K.EQ.'99')GO TO 140
41200 C 99=BACKUP
41300 31 IF(LOOKD(K))GO TO 56
41400 C JUMP IF FILE FOUND
41500 TYPE 55
41600 GO TO 15
41700 55 FORMAT(' FILE NOT FOUND'/)
41750 11 FORMAT(A5,I)
41800 56 NMS(KA)=K
41810 CC IF(ML.EQ.' ')GO TO 5
41820 IF(ML.EQ.0)GO TO 5
41855 RJH='Y'
41877 GO TO 21
41900 5 TYPE 8
42000 ACCEPT FA5,RJH
42100 IF(RJH.EQ.'99')GO TO 15
42200 IF(RJH.NE.'Y')RJH=0
42300 IF(RJH.EQ.0)REREAD F78F,RJH
42400 C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500 21 RMOV1(KA+1)=RJH
42600 RMOV2(KA)=RJH
42700 GO TO 3
42800 140 KA=KA-1
42900 GO TO 15
43000
43100 10 KB=KA-1
43200 TYPE 9
43300 ACCEPT F78F,RSIZ
43400 IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500 KA=0
43600
43700 1 IF(NAME.NE.0)GO TO 12
43800 IF(KA.EQ.KB)CALL EXIT
43900 NAME=NMS(KA+1)
44000 TYPE 111,NAME
44100 RETURN
44200 12 KA=KA+1
44300 NAME=0
44400 RJD=1
44500 IF(INP(3).EQ.'C')RJD=0
44600 C 'PXC' = CALCOMP OUTPUT
44700 RJH=0
44800 RJB=RSIZ
44900 RJC=RSIZ
45000 RJG=0
45100 RJE=1
45200 RJF=1
45300 IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400 IF(RMOV1(KA).NE.0)RJE=0
45500 IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600 2 FORMAT(' TYPE FILE NAME',I2,1X$)
45700 8 FORMAT(' MOVE UP AT END? ',$)
45800 9 FORMAT(' SIZE FACTOR? ',$)
45900 111 FORMAT(1XA5/)
46000 END